{***************************************************************************}
{                                                                           }
{           Spring Framework for Delphi                                     }
{                                                                           }
{           Copyright (C) 2009-2011 DevJET                                  }
{                                                                           }
{           http://www.spring4d.org                                         }
{                                                                           }
{***************************************************************************}
{                                                                           }
{  Licensed under the Apache License, Version 2.0 (the "License");          }
{  you may not use this file except in compliance with the License.         }
{  You may obtain a copy of the License at                                  }
{                                                                           }
{      http://www.apache.org/licenses/LICENSE-2.0                           }
{                                                                           }
{  Unless required by applicable law or agreed to in writing, software      }
{  distributed under the License is distributed on an "AS IS" BASIS,        }
{  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. }
{  See the License for the specific language governing permissions and      }
{  limitations under the License.                                           }
{                                                                           }
{***************************************************************************}

unit Spring.Serialization.ReferenceProvider;

interface

uses
  Rtti,
  Spring.Serialization,
  Spring.Serialization.Base;

type

{$REGION 'Defines ReferenceProvider'}


  {$REGION 'Documentation'}
  ///	<summary>Ordinary property reference of class.</summary>
  ///	<remarks>
  ///	  As built in RTTI mechanism supports only properties of classes, this
  ///	  class only reflect the properties on objects.
  ///	  <note type="note">This may change in future Delphi issues.</note>
  ///	</remarks>
  {$ENDREGION}
  TPropertyReference = class(TMemberReference)
  protected
    function GetReferenceType: TRttiType; override;
    function GetValue: TValue; override;
    procedure DoSetValue(const value: TValue); override;
    function GetIsReadOnly: Boolean; override;
    function GetIsWriteOnly: Boolean; override;
  end;

  {$REGION 'Documentation'}
  ///	<summary>Defines field reference being.</summary>
  ///	<remarks>
  ///	  <note type="note">FieldReference are used in serialization process only
  ///	  on records and classes as built in RTTI mechanism supports only those
  ///	  types to embed rtti info in it.</note>
  ///	</remarks>
  {$ENDREGION}
  TFieldReference = class(TMemberReference)
  protected
    function GetReferenceType: TRttiType; override;
    function GetValue: TValue; override;
    procedure DoSetValue(const value: TValue); override;
    function GetIsReadOnly: Boolean; override;
    function GetIsWriteOnly: Boolean; override;
  end;

  {$REGION 'Documentation'}
  ///	<summary>It defines virtual which means just fake properties of
  ///	interfaces as built in RTTI mechanism does not support properties on
  ///	interfaces.</summary>
  ///	<remarks>
  ///	  <para>Fake properties are built on names of the setter and getter
  ///	  methods.</para>
  ///	  <note type="note">Internally it takes the method name and match the
  ///	  core name of it with the serialized core "property" name.</note>
  ///	</remarks>
  {$ENDREGION}
  TVirtualPropertyReference = class(TMemberReference)
  private
    fSetter: TRttiMethod;
  protected
    function GetName: string; override;
    function GetReferenceType: TRttiType; override;
    function GetValue: TValue; override;
    procedure DoSetValue(const value: TValue); override;
    function GetIsReadOnly: Boolean; override;
    function GetIsWriteOnly: Boolean; override;
  public
    constructor Create(const instance: TValue;
      const accessors: TArray<TRttiMethod>;
      const parent: IReferenceProvider); reintroduce;
  end;

  {$REGION 'Documentation'}
  ///	<summary>It represents the ValueType type of he serialized
  ///	element.</summary>
  ///	<remarks>Each entry point of serialization is probably an ValueType so it
  ///	is actually an entry point of serialization process.</remarks>
  {$ENDREGION}
  TValueReference = class(TReferenceProviderBase)
  private
    fValue: TValue;
  protected
    function GetName: string; override;
    function GetReferenceType: TRttiType; override;
    function GetAttributes: TArray<TCustomAttribute>; override;
    function GetValue: TValue; override;
    procedure DoSetValue(const value: TValue); override;
    function GetIsReadOnly: Boolean; override;
    function GetIsWriteOnly: Boolean; override;
  public
    constructor Create(const value: TValue; const parent: IReferenceProvider);
  end;

{$ENDREGION}

  TMethodReference = class(TInterfacedObject, IMethodReference)
  private
    fInstance: TValue;
    fRttiMethod: TRttiMethod;
  public
    constructor Create(const instance: TValue; const rttiMethod: TRttiMethod);

    function Invoke(const Args: array of TValue): TValue;
  end;

implementation

uses
  TypInfo,
  SysUtils,
  Generics.Collections;


{$REGION 'TPropertyReference'}

procedure TPropertyReference.DoSetValue(const value: TValue);
begin
  inherited;

  fMember.AsProperty.SetValue(fInstance.AsObject, value);
end;

function TPropertyReference.GetIsReadOnly: Boolean;
begin
  if Assigned(fMember) and
    fMember.IsProperty then
  begin
    Result := not fMember.AsProperty.IsWritable;
  end
  else
    Result := False;
end;

function TPropertyReference.GetIsWriteOnly: Boolean;
begin
  if Assigned(fMember) and
    fMember.IsProperty then
  begin
    Result := not fMember.AsProperty.IsReadable;
  end
  else
    Result := False;
end;

function TPropertyReference.GetReferenceType: TRttiType;
begin
  if Assigned(fMember) and
    fMember.IsProperty then
  begin
    Result := fMember.AsProperty.PropertyType;
  end
  else
    Result := Reflector.GetType(fInstance.TypeInfo);
end;

function TPropertyReference.GetValue: TValue;
begin
  if Assigned(fMember) and
    fMember.IsProperty then
  begin
    if fInstance.IsObject then
      Result := fMember.AsProperty.GetValue(fInstance.AsObject)
    else
      Result := fMember.AsProperty.GetValue(fInstance.GetReferenceToRawData);
  end
  else
    Result := fInstance;
end;

{$ENDREGION}


{$REGION 'TFieldReference'}

procedure TFieldReference.DoSetValue(const value: TValue);
begin
  inherited;

  if fInstance.IsObject then
    fMember.AsField.SetValue(fInstance.AsObject, value)
  else
    fMember.AsField.SetValue(fInstance.GetReferenceToRawData, value);
end;

function TFieldReference.GetIsReadOnly: Boolean;
begin
  Result := not (Assigned(fMember) and
    fMember.IsField);
end;

function TFieldReference.GetIsWriteOnly: Boolean;
begin
  Result := IsReadOnly;
end;

function TFieldReference.GetReferenceType: TRttiType;
begin
  if Assigned(fMember) and
    fMember.IsField then
  begin
    Result := fMember.AsField.FieldType;
  end
  else
    Result := Reflector.GetType(fInstance.TypeInfo);
end;

function TFieldReference.GetValue: TValue;
begin
  if Assigned(fMember) and
    fMember.IsField then
  begin
    if fInstance.IsObject then
      Result := fMember.AsField.GetValue(fInstance.AsObject)
    else
      Result := fMember.AsField.GetValue(fInstance.GetReferenceToRawData);
  end
  else
    Result := fInstance;
end;

{$ENDREGION}


{$REGION 'TVirtualPropertyReference'}

constructor TVirtualPropertyReference.Create(const instance: TValue;
  const accessors: TArray<TRttiMethod>; const parent: IReferenceProvider);
begin
  fInstance := instance;
 if Assigned(accessors[0]) then
    fMember := accessors[0];

  if Assigned(accessors[1]) then
    fSetter := accessors[1];
end;

procedure TVirtualPropertyReference.DoSetValue(const value: TValue);
begin
  inherited;

  fSetter.Invoke(fInstance, [value]);
end;

function TVirtualPropertyReference.GetIsReadOnly: Boolean;
begin
  Result := not Assigned(fSetter);
end;

function TVirtualPropertyReference.GetIsWriteOnly: Boolean;
begin
  Result := not Assigned(fMember);
end;

function TVirtualPropertyReference.GetName: string;
var
  rttiType: TRttiType;
begin
  if Assigned(fMember) and fMember.IsMethod then
    Result := StringReplace(fMember.Name, 'Get', '', [rfReplaceAll])
  else
    begin
      rttiType := Reflector.GetType(fInstance.TypeInfo);
      if Assigned(rttiType) then
        Result := rttiType.QualifiedName
      else
        Result := '';
    end;
end;

function TVirtualPropertyReference.GetReferenceType: TRttiType;
begin
  if Assigned(fMember) and
    fMember.IsMethod then
  begin
    Result := fMember.AsMethod.ReturnType;
  end
  else
    Result := Reflector.GetType(fInstance.TypeInfo);
end;

function TVirtualPropertyReference.GetValue: TValue;
begin
  if Assigned(fMember) then
    Result := fMember.AsMethod.Invoke(fInstance, [])
  else
    Result := fInstance;
end;

{$ENDREGION}


{$REGION 'TValueReference'}

constructor TValueReference.Create(const value: TValue;
  const parent: IReferenceProvider);
begin
  inherited Create;

  fValue := value;
  fParent := parent;
end;

procedure TValueReference.DoSetValue(const value: TValue);
begin
  inherited;

  fValue := value;
end;

function TValueReference.GetAttributes: TArray<TCustomAttribute>;
begin
  SetLength(Result, 0);
end;

function TValueReference.GetIsReadOnly: Boolean;
begin
  Result := False;
end;

function TValueReference.GetIsWriteOnly: Boolean;
begin
  Result := False;
end;

function TValueReference.GetName: string;
begin
  if Parent = nil then
    Result := CInstanceCollectionCodeName
  else
    begin
      if Value.Kind in [tkClass, tkInterface, tkRecord, tkArray] then
        Result := CItemCollectionCodeName
      else
        Result := CValueAttributeName;
    end;
end;

function TValueReference.GetReferenceType: TRttiType;
begin
  if fValue.IsEmpty and
    Assigned(Parent) then
  begin
    Result := Parent.ReferenceType;
  end
  else
    Result := Reflector.GetType(fValue);
end;

function TValueReference.GetValue: TValue;
begin
  Result := fValue;
end;

{$ENDREGION}


{ TMethodReference }

constructor TMethodReference.Create(const instance: TValue;
  const rttiMethod: TRttiMethod);
begin
  inherited Create;

  fInstance := instance;
  fRttiMethod := rttiMethod;
end;

function TMethodReference.Invoke(const Args: array of TValue): TValue;
begin
  Result := fRttiMethod.Invoke(fInstance, Args);
end;

end.
